home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / scheme / syntax.t < prev    next >
Text File  |  1990-06-08  |  6KB  |  189 lines
  1. (herald syntax (env tsys))
  2.  
  3. ;;; Copyright (c) 1985, 1987 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, K Pitman, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer
  6. ;;; Science Department.  Permission to copy this software, to redistribute it,
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warranty or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; Modified by Ashwin Ram, July 1985
  27.  
  28. ;;; Further modifications for R^RS conformity by J Rees, December 1987
  29.  
  30. (define scheme-syntax-table
  31.    (env-syntax-table scheme-env))
  32.  
  33. (define (t-syntax sym)
  34.    (syntax-table-entry standard-syntax-table sym))
  35.  
  36. (define (scheme-syntax sym)
  37.    (syntax-table-entry scheme-syntax-table sym))
  38.  
  39. (define (scheme-atom-expander atom)
  40.   (cond ((symbol? atom)
  41.          `(,(t-syntax 'variable-value) ,atom))   
  42.         ((or (number?  atom)         ; self evaluating
  43.              (string?  atom)
  44.              (char?    atom)
  45.              (boolean? atom))
  46.          `(,(t-syntax 'quote) ,atom))           
  47.         ((null? atom)
  48.          (warning "~S in evaluated position~%" atom)
  49.          `(,(t-syntax 'quote) ,atom))
  50.         (else
  51.          (syntax-error "unevaluable datum - ~S" atom))))
  52.  
  53. (set ((*value t-implementation-env 'atom-expander) scheme-syntax-table) 
  54.      scheme-atom-expander) 
  55.  
  56. (define (definition? exp)
  57.    (and (pair? exp) (eq? (car exp) 'define)))
  58.  
  59. (define (parse-define pat body)
  60.    (cond ((atom? pat)
  61.           (return pat (car body)))
  62.          (else
  63.           (return (car pat)
  64.                   `(,(t-syntax 'named-lambda)
  65.             ,(car pat)
  66.             ,(cdr pat)
  67.             ,@(process-body body))))))
  68.  
  69. (define (parse-top-level-define pat body k)
  70.   (receive (var val) (parse-define pat body) (k var val)))
  71.  
  72. ; Peel definitions off front of body, and assemble an appropriate LABELS
  73. ; expression if any are found.
  74.  
  75. (define (process-body exp-list)
  76.   (let ((assemble (lambda (e d) 
  77.             (if (null? d)
  78.             e
  79.             `((,(t-syntax 'labels) ,(reverse d) ,@e))))))
  80.     (iterate -loop- ((e exp-list)
  81.              (d '()))
  82.       (cond ((null? e)
  83.          ;; Not a particularly useful diagnostic, but...
  84.          (syntax-error "null body - ~S" exp-list)
  85.          (assemble '(0) d))
  86.         (else
  87.          (let ((exp (car e)))
  88.            (cond ((definition? exp)
  89.               (receive (name val) (parse-define (cadr exp) (cddr exp))
  90.             (-loop- (cdr e)
  91.                 (cons `(,name ,val) d))))
  92.              (else (assemble e d)))))))))
  93.  
  94.  
  95.  
  96. (define-local-syntax (define-scheme-syntax pat . body)
  97.   (let ((foo (lambda (name val)
  98.                 `(set (syntax-table-entry scheme-syntax-table ',name)
  99.                       ,val))))
  100.      (cond ((atom? pat)
  101.             (foo pat (car body)))
  102.            (else
  103.             (foo (car pat) `(macro-expander ,pat . ,body))))))
  104.  
  105. ;; collect  --??
  106.  
  107. (define-scheme-syntax (cons-stream hd tl)
  108.   `(cons ,hd (,(t-syntax 'delay) ,tl)))
  109.  
  110. ;; This isn't quite right; if a DEFINE is found in a weird place, an
  111. ;; error should be signalled.
  112.  
  113. ;; Also, DEFINE should check its syntax, so that (DEFINE A B C) is an
  114. ;; error, not the same as (DEFINE A B) as it is now.
  115.  
  116.  
  117. (define-scheme-syntax (define pat . body)
  118.    (parse-top-level-define
  119.       pat body
  120.           (lambda (name val)
  121.              `(,(t-syntax 'block)
  122.         (,(t-syntax 'lset-variable-value) ,name ,val)
  123.         ',name))))
  124.  
  125. (define-scheme-syntax (lambda vars . body)
  126.   `(,(t-syntax 'lambda) ,vars ,@(process-body body)))
  127.  
  128. ;;; "Named" LET 
  129.  
  130. (define-scheme-syntax (let specs . body)
  131.   (if (or (pair? specs) (null? specs))
  132.       `(,(t-syntax 'let) ,specs ,@(process-body body))
  133.       `(,(t-syntax 'iterate) ,specs ,@(process-body body))))
  134.  
  135. (define-scheme-syntax (let* specs . body)
  136.   `(,(t-syntax 'let*) ,specs ,@(process-body body)))
  137.  
  138. (define-scheme-syntax (letrec specs . body)
  139.   `(,(t-syntax 'labels) ,specs ,@(process-body body)))
  140.  
  141. ;;; Is LOCALE no longer supported in T3?  If so, flush this or redefine
  142. ;;; it in terms of MAKE-LOCALE and EVAL!
  143.  
  144. (define-scheme-syntax (make-environment . body)  ;Yow!
  145.   (let ((name (generate-symbol 'make-environment)))
  146.     `(,(t-syntax 'locale) ,name ,@body ,name)))
  147.  
  148. ;;; Permit PC-Scheme use of SET! like T's SET (e.g. (SET! (CAR X) Y)).
  149.  
  150. (define-scheme-syntax (set! var val)
  151.   `(,(t-syntax 'set) ,var ,val))
  152.  
  153. (define-scheme-syntax sequence (t-syntax 'block))
  154. (define-scheme-syntax begin    (t-syntax 'block))
  155.  
  156. (walk (lambda (sym)
  157.          (set (syntax-table-entry scheme-syntax-table sym)
  158.               (syntax-table-entry standard-syntax-table sym)))
  159.       '(quote
  160.         quasiquote
  161.         cond
  162.         if
  163.         and
  164.         or
  165.         do
  166.         case
  167.         delay
  168.         block              ;; T2.8's internal macros use BLOCK, not #[Syntax BLOCK]. Sigh.
  169.         pp
  170.         trace
  171.         untrace
  172.         locative           ;; for TRACE
  173.         var-locative       ;; for TRACE
  174.         ignore
  175.         ignorable
  176.     time
  177.         select
  178.     define-syntax
  179.     define-local-syntax
  180.     define-constant
  181.     ))           ;; OBJECT (for PP hack) (probably no longer needed - JAR)
  182.  
  183. (define-scheme-syntax (access var env)
  184.  `(environment-ref ,env ',var))
  185.  
  186.  
  187. ;;****************************************************************************
  188. 'SCHEME_SYNTAX
  189.